home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Mac100% 1998 November
/
MAC100-1998-11.ISO.7z
/
MAC100-1998-11.ISO
/
オンラインソフト定点観測
/
ユーティリティ
/
Mops 3.2.sea
/
Mops 3.2
/
Mops source
/
PPC source
/
pnuc2
< prev
next >
Wrap
Text File
|
1998-06-13
|
16KB
|
845 lines
marker m__pnuc2
¥ ======================
¥ I/O
¥ ======================
0 value BUSY ¥ FCB of file involved in asynchronous I/O, or zero if none.
¥ Set from high level, not from here. Cleared here though,
¥ by the completion routine.
0 value CPADDR ¥ Completion routine address, or zero if none. Also serves
¥ as a flag that the next op is to be asynchronous.
¥ *** Actually, I'm not going to attempt asynch I/O on the PPC yet, since I
¥ don't want to have to worry about UPP callbacks!
¥ ===========================
¥ OTHER SYSTEM CALLS
¥ ===========================
¥ we can omit all the handle and pointer stuff here in the nucleus, and just
¥ use SYSCALLs in pStruct.
sysCall FreeMem
sysCall MaxMem
sysCall EventAvail
sysCall WaitNextEvent
sysCall FindWindow
sysCall BlockMoveData
: FREE FreeMem ;
variable growBytes
: FREEBLK growBytes MaxMem ;
: EVENT? ¥ ( mask -- b )
fEvent EventAvail 0<> ;
: ?EVENT event? ; ¥ legacy name
: NEXTEVENT ¥ ( ^event mask -- b )
swap
TEidle_vect
sleepTicks
MMRgn
WaitNextEvent
;
variable WPtr
: FIND-WINDOW ¥ ( point -- part# ^window )
WPtr
FindWindow
WPtr @ ;
¥ =========================
¥ LOW-LEVEL STRING HANDLING
¥ =========================
: FILL { addr len char -- }
len 0EXIT
len FOR
char addr c!
1 ++> addr
NEXT
;
: ERASE ¥ ( addr len -- )
0 fill ;
: BLANKS ¥ ( addr len -- )
$ 20 fill ;
: (S=) { addr1 addr2 len -- b }
len
FOR addr1 c@ addr2 c@ <>
IF UNFOR false EXIT THEN
1 ++> addr1 1 ++> addr2
NEXT
true ;
: S= { addr1 len1 addr2 len2 -- b }
len1 len2 =
IF addr1 addr2 len1 (s=)
ELSE false
THEN
;
(* MOVE and ALIGNED_MOVE.
There's a small problem with MOVE in that it is required by the standard to
move the data exactly even if the areas overlap, without propagation effects.
"Undefined on overlap" would have allowed better optimization possiblities,
although there are probably some situations where the other behavior is
better. Anyway we provide both. We do the "undefined on overlap" with
ALIGNED_MOVE, which also requires the beginning addresses to be aligned,
which they usually are anyway. For MOVE, we call BlockMoveData, which
does the right thing, and does it well, especially for the longer moves.
There's about a 28 instruction overhead, but the actual moves are optimum
for whatever processor we're running on. So even for ALIGNED_MOVE, we
call BlockMoveData if the move is long, since for a long enough move there'll
always be an advantage in using a processor-specific optimized sequence.
We assume that we're not moving code, only data, so we use BlockMoveData
rather than BlockMove which flushes the caches.
Note we also made this assumption on the 68k, since although we used
BlockMove (BlockMoveData not being available on all systems) if possible
we optimized small moves to some inline MOVE instructions without a cache
flush.
Note also that in a future version the code given here for ALIGNED_MOVE
might not always be called if the byte count is a literal. In this case
we could sometimes generate a better inline sequence.
*)
: MOVE ¥ ( src dst len -- )
dup NIF drop 2drop EXIT THEN
BlockMoveData ;
$ BD36 ' move 2- w! ¥ move_h handler code
: ALIGNED_MOVE { src dst len ¥ cnt -- }
len 0<= ?EXIT
len 32 <=
IF len 2 >> -> cnt
cnt FOR src @ dst !
4 ++> src 4 ++> dst
NEXT
len 3 and -> cnt
cnt FOR src c@ dst c!
1 ++> src 1 ++> dst
NEXT
ELSE
src dst len BlockMoveData
THEN
;
¥ $ BD37 ' aligned_move 2- w! ¥ alignedMove_h handler code
: CMOVE { src dst len -- }
len FOR
src c@ dst c!
1 ++> src 1 ++> dst
NEXT
;
: UPPER { addr len -- }
len FOR
addr c@
& a & z within?
IF $ 20 xor addr c! ELSE drop THEN
1 ++> addr
NEXT
;
(* These words are used by the input parsing section.
SCAN ( addr len c -- addr' len' ) searches the string ( addr len )
for the character c. addr' is the address of the matching char,
and len' is the remaining length (including the matching char). If no
match, len' will be zero.
Class String+ provides a more complete implementation in its
chsearch: method, which has case handling. In the 68k version,
SCAN only handles a 16-bit length - we don't have this restriction
in the PPC version, although if you exploit this feature your
code won't work on the 68k.
*)
: SCAN { addr len char -- addr' len' }
len FOR
addr c@ char =
IF UNFOR addr len EXIT THEN
1 ++> addr 1 --> len
NEXT
addr 0
;
: SKIP { addr len char -- addr' len' }
len FOR
addr c@ char <>
IF UNFOR addr len EXIT THEN
1 ++> addr 1 --> len
NEXT
addr 0
;
: /STRING { addr len n -- addr' len' }
addr n +
len n -
;
¥ ==========================
¥ INPUT PARSING etc.
¥ ==========================
: SOURCE ¥ ( -- addr len )
src-start src-len ;
: REST ¥ ( -- addr len )
src-start >in @ +
src-len >in @ -
;
: SCAN-SRC { c -- }
¥ Scans the input stream for c. Leaves the source
¥ updated to the next character, (so it could be empty if the found char
¥ was the last in the buffer) or overshot if none found (>IN exceeding
¥ SRC-LEN). The caller will need to check for this.
rest c scan
src-len swap - 1+ >in !
drop ;
: SKIP-SRC { c -- }
¥ Skips consecutive delimiters equal to c in the source.
¥ Leaves source updated to the next character, or empty if none.
rest c skip
src-len swap - >in !
drop ;
: SKIP-SRC+ { c -- }
¥ Skips consecutive delimiters equal to c in the source.
¥ If the source gets exhausted before a non-delimiter is found,
¥ keeps calling REFILL to get more.
BEGIN
c skip-src
>in @ src-len < ?EXIT ¥ out on success
refill ¥ get next input line
NUNTIL ¥ loop if we got it
154 die ¥ "unexpected end of file"
;
: PARSE { c ¥ len -- addr len }
¥ Scans the source for delimiter c. Returns
¥ the addr and len of the parsed string, and updates the source
¥ to the remaining string.
>in @
c scan-src
>in @ over - 1- -> len
src-start + len
;
: PARSE-WORD ( c -- addr len )
¥ As for PARSE, but any consecutive initial delimiters are
¥ skipped. If the input is exhausted in the process,
¥ REFILL is called to get more.
dup skip-src+ parse ;
: PARSE-DLM-STR { c -- addr len }
¥ Scans the source for a string delimited at the
¥ start and end by c. Everything is skipped before the first delimiter.
¥ If the source gets exhausted in the process, REFILL is called to get
¥ more.
BEGIN
c scan-src
>in @ src-len <
IF c parse EXIT THEN ¥ found
refill
NUNTIL
154 die ¥ "unexpecte end of file"
;
: "STR" ( -- addr len ) ¥ Scans for a string delimited by "..."
& " parse-dlm-str ;
: PLACE { addr1 len addr2 -- }
¥ Converts string ( addr1 len ) to a counted string at addr2.
¥ Appends 3 zero bytes, which may be needed for padding, as
¥ well as making it a valid C string.
addr2 len + 1+ 3 erase ¥ append zero bytes
len addr2 c! ¥ store count byte
addr1 addr2 1+ len cmove ¥ move string bytes over
;
: WORD { c ¥ addr -- addr }
¥ Parses the source using c as the delimiter (using PARSE-WORD).
¥ Moves the resulting string as a counted string to HERE, and returns
¥ this address.
c parse-word
CDP #align4 -> addr
addr place
addr
;
: WORD" ( -- addr )
& " word ;
: MWORD ( -- addr )
¥ "Mops word". Called by DEFINED? which is called
¥ by INTERPRET.
¥ Calls WORD with a blank as delimiter, and converts the string
¥ to upper case. Leaves counted string at addr (will be HERE).
bl word
case_in_names? ?EXIT
dup count upper ;
: (,STR) ( addr len --)
tuck here place
1+ #align4 allot ;
: ,STR ( c -- )
¥ c is delimiter. Adds the following text until delimiter
¥ to the DATA AREA as a counted string.
parse (,str) ;
: ,DLM-STR ( c -- )
¥ Scans the source for a string delimited at the
¥ start and end by c, then adds it to the dictionary.
parse-dlm-str (,str) ;
: ," ( -- ) ¥ Adds text till " to the dictionary.
& " ,str ;
: ,"STR" ( -- ) ¥ Adds text delimited by " at the start and end.
& " ,dlm-str ;
¥ .( - see below, after TYPE
: (
& ) parse 2drop ; ppc_immediate
: ¥
0 -> src-len ; ppc_immediate
¥ ======================
¥ SCREEN OUTPUT
¥ ======================
¥ First, the sysCalls and low-level stuff:
sysCall MoveTo
sysCall EraseRect
sysCall SetOrigin
sysCall Line
sysCall ScrollRect
sysCall GetPen
sysCall GetPenState
sysCall SetPenState
sysCall PenMode
sysCall DrawChar
sysCall DrawText
: HOME
8 15 MoveTo ;
: CLS
fpRect EraseRect ;
: SCROLL { x y -- }
emit? 0EXIT
fpRect x y theRgn ScrollRect ;
: >ORIGIN ¥ ( x y --)
SetOrigin ;
: GOTOXY ¥ ( x y -- )
MoveTo ;
: @XY ¥ ( -- x y )
tempVbl GetPen
tempVbl 2+ w@
tempVbl w@
;
: .CURS ( -- )
emit? 0EXIT
curs? 0EXIT
tempVbl GetPenState
10 PenMode
7 0 Line
tempVbl SetPenState
;
: CONTBOT ( -- n )
thePort $ A0 + w@ ;
: CONTTOP ( -- n )
thePort $ 9C + w@ ;
: #LEAD { ¥ addr -- n }
thePort -> addr
thePort $ 4A + w@
dup NIF ¥ zero point size, i.e. no font set. We just return 4 so Scroll
¥ doesn't crash.
drop 4 EXIT
THEN
120 * 50 + 100 /
;
: #LINES ( -- n )
contBot contTop - #lead / 1- ;
: BOTTOM ( -- n )
#lead #lines 1- *
15 + contTop + ;
¥ ---------------- CR -----------------
: (CR) ( -- )
.curs
@xy nip 8 swap
dup bottom >=
IF 0
#lead negate scroll
gotoXY
ELSE
#lead + gotoXY
THEN
.curs
;
' (cr) sVect CRVEC
: CR crVec ;
¥ ---------------- EMIT -----------------
: (EMIT) { c -- }
emit? 0EXIT
c $ D =
IF crVec
ELSE
.curs c DrawChar .curs
THEN
;
' (emit) sVect EMITVEC
' (emit) sVect ECHOVEC
: EMIT ¥ ( c -- )
1 ++> out emitVec ;
¥ ---------------- TYPE -----------------
: (TYPE) { addr len -- }
emit? 0EXIT
.curs
addr 0 len DrawText
.curs
;
' (type) sVect TYPEVEC
: TYPE ( addr len -- )
dup ++> out typeVec ;
: .(
& ) parse type ; ppc_immediate
¥ -------------- SPACE & SPACES ---------------
: SPACE bl emit ;
: (SPACES) { n -- }
emit? 0EXIT
n 0<= ?EXIT
n padLen min -> n
pad n bl fill
pad n (type)
;
' (spaces) sVect SPVEC
: SPACES ¥ ( n -- )
dup ++> out spVec ;
¥ We only use (BS) internally, so we don't define a BS.
: (BS)
.curs ¥ erases any cursor on screen
curs? false -> curs?
@xy swap 6 - 8 max swap
2dup gotoXY space gotoXY
-> curs?
.curs ¥ draw cursor at new position
;
: +ECHO true -> echo? ;
: -ECHO false -> echo? ;
: +CURS true -> curs? ;
: -CURS false -> curs? ;
: CURS curs? ; ¥ for backward compatibility
¥ ===============================
¥ KEYBOARD INPUT
¥ ===============================
: KEY? ( -- b )
$ 28 event? ;
: ?TERMINAL ( -- b ) ¥ the old name
key? ;
: (KEY) { ¥ what -- c }
BEGIN
fEvent ¥ addr of our event record
$ 843A ¥ Mask - we'll accept key down, auto-key,
¥ mouse-down, high-level and OS events.
nextEvent
IF ¥ we've got something
fEvent w@ -> what ¥ get What field of fEvent
what 3 = what 5 = or
IF ¥ we've got a key
fEvent 5 + c@ ¥ low byte of message field is ASCII key value
EXIT
ELSE
what 23 =
IF ¥ High-level event - presumably oapp.
¥ We'll just ignore it.
THEN
THEN
THEN
AGAIN
;
' (key) sVect KEY
forward get_$input
:f get_$input pad 0 ;f
: bs_acc
#tib @ ¥ at start of TIB?
IF (bs) ¥ no - fix screen
-1 #tib +! ¥ and back up
ELSE
4 beep ¥ yes - beep
THEN
;
: key_acc { ¥ c loop? -- c }
¥ Reads one key for ACCEPT. Handles backspaces and tabs.
BEGIN
false -> loop?
key -> c
¥ first we check for the chars which we don't echo
c 8 =
IF bs_acc ¥ handle backspace
ELSE
c $ FF =
IF ¥ ignore FF
ELSE ¥ we echo everything else and don't loop
c 3 =
IF $ D -> c ¥ <enter> replaced with <return>
ELSE
c 9 =
IF bl -> c ¥ tab replaced with blank
THEN
THEN
c echoVec ¥ echo char however we're set up to do it
c EXIT
THEN
THEN
AGAIN
;
: ACCEPT { addr max_len ¥ c -- #chars }
0 #tib !
¥ Is there pending input from the Mops window?
get_$input ?dup
IF ¥ yes - move it to the destination. We can
¥ assume special chars have been filtered.
max_len min
dup #tib !
addr swap cmove EXIT
THEN
drop
BEGIN
key_acc -> c
c $ D =
IF #tib @ EXIT THEN
#tib @ max_len <
IF c addr #tib @ + c! ¥ still room in buff - store char
1 #tib +!
THEN
AGAIN
;
: SET_SOURCE
TIB -> src-start
#tib @ -> src-len
0 >in !
;
: QUERY
TIB TIBlen accept drop
set_source
0 -> source-ID
;
:f REFILL ( -- b ) ¥ attempts to (re)fill the input stream with another line.
source-ID dup
NIF ¥ it's from the keyboard
drop query
true
ELSE
-1 =
IF ¥ it's from an EVALUATEd string - none left
false
ELSE ¥ it's from a file
fRefill ¥ - fRefill does the job, and returns the flag.
THEN
THEN
1 ++> #lines_read
;f
¥ =====================
¥ NUMBER INPUT
¥ =====================
: >NUMBER ( ud-lo ud-hi ) { addr len -- ud-lo' ud-hi' addr' len' }
len 0>
IF
BEGIN
addr c@ 1 ++> addr
base digit
NIF 1 --> addr false
ELSE
( ud-lo ud-hi digit )
swap base * rot base um* d+
dpl 0>= IF 1 ++> dpl THEN
1 --> len
len 0>
THEN
NUNTIL
THEN
( ud-lo' ud-hi' ) addr len
;
: ?NOTFOUND ( flag -- )
NIF -13 die THEN ¥ "undefined word"
;
: NUM? { addr len ¥ start neg? done? -- n true | -- n-lo n-hi true | -- false }
false -> neg? false -> done?
len NIF false EXIT THEN
addr c@ & - =
IF ¥ 1st char was minus
true -> neg?
1 ++> addr 1 --> len
THEN
addr -> start ¥ remember initial addr
-1 -> dpl ¥ no decimal point seen yet
0 0 ¥ initial number is a double zero
BEGIN
addr len >number ¥ accumulate digits into number
-> len -> addr ¥ update string addr & len
len
IF addr c@ & . =
IF addr -> dpl
1 ++> addr 1 --> len
ELSE
true -> done?
THEN
ELSE
true -> done?
THEN
done?
UNTIL
¥ we've hit a non-digit or the string is exhausted.
len IF 2drop false EXIT THEN ¥ 'number' not completed - probably
¥ bad char in number
addr start = IF 2drop false EXIT THEN ¥ no chars processed - not a number
dpl 0>=
IF ¥ decimal point seen - it's a double number
neg? IF dnegate THEN
ELSE
drop ¥ want a single number - drop hi cell
neg? IF negate THEN
THEN
true
;
: NUMBER ( addr -- n ) ¥ returns the number at addr, or if none,
¥ gives "undefined word" error.
count num? ?notFound ;
¥ LITERAL is immediate so we'll leave it till the end.
¥ head $47,LITERAL,literal ; LITERAL
¥ callh hLiteral
¥ RTS
¥ =============================
¥ NUMBER OUTPUT
¥ =============================
: HOLD ( c -- )
1 --> hld hld c! ;
: <# ( d -- d )
pad -> hld ;
: #> ( d -- )
2drop
hld pad over - ;
: SIGN ( n -- )
0< IF & - hold THEN ;
(*
: #
drop ¥ get rid of hi-order cell (assumed to be zero)
base u/mod
swap
dup 9 > IF 7 + THEN
& 0 + hold
0
;
*)
: #
base 0 ud/mod 2swap drop
dup 9 > IF 7 + THEN
& 0 + hold
;
: #S ( d -- d' )
BEGIN # 2dup or NUNTIL ;
¥ : HEX 16 -> base ;
¥ : DECIMAL 10 -> base ;
: .R { n #to-right -- }
n abs 0
<# #s n sign #>
#to-right over - spaces
type
;
: . ¥ ( n -- )
0 .r space ;
: .H
base 16 -> base
swap .
-> base ;
: U.
0 <# #s #> type space ;
: N>COUNT
count $ 1F and ;